home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / XLISP.LZH / XLISPSRC.ARC / XLCONT.C < prev    next >
Text File  |  1986-05-17  |  20KB  |  957 lines
  1. /* xlcont - xlisp special forms */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern NODE *xlenv,*xlvalue;
  10. extern NODE *s_car,*s_cdr,*s_nth,*s_get,*s_svalue,*s_splist,*s_aref;
  11. extern NODE *s_lambda,*s_macro;
  12. extern NODE *s_comma,*s_comat;
  13. extern NODE *true;
  14.  
  15. /* forward declarations */
  16. FORWARD NODE *bquote1();
  17. FORWARD NODE *defun();
  18. FORWARD NODE *let();
  19. FORWARD NODE *prog();
  20. FORWARD NODE *progx();
  21. FORWARD NODE *doloop();
  22.  
  23. /* xquote - special form 'quote' */
  24. NODE *xquote(args)
  25.   NODE *args;
  26. {
  27.     if (atom(args))
  28.     xlfail("too few arguments");
  29.     else if (cdr(args) != NIL)
  30.     xlfail("too many arguments");
  31.     return (car(args));
  32. }
  33.  
  34. /* xfunction - special form 'function' */
  35. NODE *xfunction(args)
  36.   NODE *args;
  37. {
  38.     NODE *val;
  39.  
  40.     /* get the argument */
  41.     val = xlarg(&args);
  42.     xllastarg(args);
  43.  
  44.     /* create a closure for lambda expressions */
  45.     if (consp(val) && car(val) == s_lambda)
  46.     val = cons(val,xlenv);
  47.  
  48.     /* otherwise, get the value of a symbol */
  49.     else if (symbolp(val))
  50.     val = xlgetvalue(val);
  51.  
  52.     /* otherwise, its an error */
  53.     else
  54.     xlerror("not a function",val);
  55.  
  56.     /* return the function */
  57.     return (val);
  58. }
  59.  
  60. /* xlambda - special form 'lambda' */
  61. NODE *xlambda(args)
  62.   NODE *args;
  63. {
  64.     NODE *fargs;
  65.  
  66.     /* get the formal argument list */
  67.     fargs = xlmatch(LIST,&args);
  68.  
  69.     /* create a new function definition */
  70.     return (cons(cons(s_lambda,cons(fargs,args)),xlenv));
  71. }
  72.  
  73. /* xbquote - back quote special form */
  74. NODE *xbquote(args)
  75.   NODE *args;
  76. {
  77.     NODE *expr;
  78.  
  79.     /* get the expression */
  80.     expr = xlarg(&args);
  81.     xllastarg(args);
  82.  
  83.     /* fill in the template */
  84.     return (bquote1(expr));
  85. }
  86.  
  87. /* bquote1 - back quote helper function */
  88. LOCAL NODE *bquote1(expr)
  89.   NODE *expr;
  90. {
  91.     NODE ***oldstk,*val,*list,*last,*new;
  92.  
  93.     /* handle atoms */
  94.     if (atom(expr))
  95.     val = expr;
  96.  
  97.     /* handle (comma <expr>) */
  98.     else if (car(expr) == s_comma) {
  99.     if (atom(cdr(expr)))
  100.         xlfail("bad comma expression");
  101.     val = xleval(car(cdr(expr)));
  102.     }
  103.  
  104.     /* handle ((comma-at <expr>) ... ) */
  105.     else if (consp(car(expr)) && car(car(expr)) == s_comat) {
  106.     oldstk = xlstack;
  107.     xlstkcheck(2);
  108.     xlsave(list);
  109.     xlsave(val);
  110.     if (atom(cdr(car(expr))))
  111.         xlfail("bad comma-at expression");
  112.     list = xleval(car(cdr(car(expr))));
  113.     for (last = NIL; consp(list); list = cdr(list)) {
  114.         new = consa(car(list));
  115.         if (last)
  116.         rplacd(last,new);
  117.         else
  118.         val = new;
  119.         last = new;
  120.     }
  121.     if (last)
  122.         rplacd(last,bquote1(cdr(expr)));
  123.     else
  124.         val = bquote1(cdr(expr));
  125.     xlstack = oldstk;
  126.     }
  127.  
  128.     /* handle any other list */
  129.     else {
  130.     oldstk = xlstack;
  131.     xlsave1(val);
  132.     val = consa(NIL);
  133.     rplaca(val,bquote1(car(expr)));
  134.     rplacd(val,bquote1(cdr(expr)));
  135.     xlstack = oldstk;
  136.     }
  137.  
  138.     /* return the result */
  139.     return (val);
  140. }
  141.  
  142. /* xsetq - special form 'setq' */
  143. NODE *xsetq(args)
  144.   NODE *args;
  145. {
  146.     NODE *sym,*val;
  147.  
  148.     /* handle each pair of arguments */
  149.     for (val = NIL; args; ) {
  150.     sym = xlmatch(SYM,&args);
  151.     val = xlevarg(&args);
  152.     xlsetvalue(sym,val);
  153.     }
  154.  
  155.     /* return the result value */
  156.     return (val);
  157. }
  158.  
  159. /* xsetf - special form 'setf' */
  160. NODE *xsetf(args)
  161.   NODE *args;
  162. {
  163.     NODE ***oldstk,*place,*value;
  164.  
  165.     /* create a new stack frame */
  166.     oldstk = xlstack;
  167.     xlsave1(value);
  168.  
  169.     /* handle each pair of arguments */
  170.     while (args) {
  171.  
  172.     /* get place and value */
  173.     place = xlarg(&args);
  174.     value = xlevarg(&args);
  175.  
  176.     /* check the place form */
  177.     if (symbolp(place))
  178.         xlsetvalue(place,value);
  179.     else if (consp(place))
  180.         placeform(place,value);
  181.     else
  182.         xlfail("bad place form");
  183.     }
  184.  
  185.     /* restore the previous stack frame */
  186.     xlstack = oldstk;
  187.  
  188.     /* return the value */
  189.     return (value);
  190. }
  191.  
  192. /* placeform - handle a place form other than a symbol */
  193. LOCAL placeform(place,value)
  194.   NODE *place,*value;
  195. {
  196.     NODE ***oldstk,*fun,*arg1,*arg2;
  197.     int i;
  198.  
  199.     /* check the function name */
  200.     if ((fun = xlmatch(SYM,&place)) == s_get) {
  201.     oldstk = xlstack;
  202.     xlstkcheck(2);
  203.     xlsave(arg1);
  204.     xlsave(arg2);
  205.     arg1 = xlevmatch(SYM,&place);
  206.     arg2 = xlevmatch(SYM,&place);
  207.     xllastarg(place);
  208.     xlputprop(arg1,value,arg2);
  209.     xlstack = oldstk;
  210.     }
  211.     else if (fun == s_svalue) {
  212.     oldstk = xlstack;
  213.     xlsave1(arg1);
  214.     arg1 = xlevmatch(SYM,&place);
  215.     xllastarg(place);
  216.     setvalue(arg1,value);
  217.     xlstack = oldstk;
  218.     }
  219.     else if (fun == s_splist) {
  220.     oldstk = xlstack;
  221.     xlsave1(arg1);
  222.     arg1 = xlevmatch(SYM,&place);
  223.     xllastarg(place);
  224.     setplist(arg1,value);
  225.     xlstack = oldstk;
  226.     }
  227.     else if (fun == s_car) {
  228.     oldstk = xlstack;
  229.     xlsave1(arg1);
  230.     if ((arg1 = xlevmatch(LIST,&place)) == NIL)
  231.         xlerror("bad argument type",arg1);
  232.     xllastarg(place);
  233.     rplaca(arg1,value);
  234.     xlstack = oldstk;
  235.     }
  236.     else if (fun == s_cdr) {
  237.     oldstk = xlstack;
  238.     xlsave1(arg1);
  239.     if ((arg1 = xlevmatch(LIST,&place)) == NIL)
  240.         xlerror("bad argument type",arg1);
  241.     xllastarg(place);
  242.     rplacd(arg1,value);
  243.     xlstack = oldstk;
  244.     }
  245.     else if (fun == s_nth) {
  246.     oldstk = xlstack;
  247.     xlstkcheck(2);
  248.     xlsave(arg1);
  249.     xlsave(arg2);
  250.     arg1 = xlevmatch(INT,&place);
  251.     arg2 = xlevmatch(LIST,&place);
  252.     xllastarg(place);
  253.     for (i = (int)getfixnum(arg1); i > 0 && consp(arg2); --i)
  254.         arg2 = cdr(arg2);
  255.     if (consp(arg2))
  256.         rplaca(arg2,value);
  257.     xlstack = oldstk;
  258.     }
  259.  
  260.     else if (fun == s_aref) {
  261.     oldstk = xlstack;
  262.     xlstkcheck(2);
  263.     xlsave(arg1);
  264.     xlsave(arg2);
  265.     arg1 = xlevmatch(VECT,&place);
  266.     arg2 = xlevmatch(INT,&place); i = (int)getfixnum(arg2);
  267.     xllastarg(place);
  268.     if (i < 0 || i >= getsize(arg1))
  269.         xlerror("index out of range",arg2);
  270.     setelement(arg1,i,value);
  271.     xlstack = oldstk;
  272.     }
  273.     else
  274.     xlfail("bad place form");
  275. }
  276.                
  277. /* xdefun - special form 'defun' */
  278. NODE *xdefun(args)
  279.   NODE *args;
  280. {
  281.     return (defun(args,s_lambda));
  282. }
  283.  
  284. /* xdefmacro - special form 'defmacro' */
  285. NODE *xdefmacro(args)
  286.   NODE *args;
  287. {
  288.     return (defun(args,s_macro));
  289. }
  290.  
  291. /* defun - internal function definition routine */
  292. LOCAL NODE *defun(args,type)
  293.   NODE *args,*type;
  294. {
  295.     NODE *sym,*fargs;
  296.  
  297.     /* get the function symbol and formal argument list */
  298.     sym = xlmatch(SYM,&args);
  299.     fargs = xlmatch(LIST,&args);
  300.  
  301.     /* make the symbol point to a new function definition */
  302.     xlsetvalue(sym,cons(cons(type,cons(fargs,args)),xlenv));
  303.  
  304.     /* return the function symbol */
  305.     return (sym);
  306. }
  307.  
  308. /* xcond - special form 'cond' */
  309. NODE *xcond(args)
  310.   NODE *args;
  311. {
  312.     NODE *list,*val;
  313.  
  314.     /* find a predicate that is true */
  315.     for (val = NIL; consp(args); args = cdr(args)) {
  316.  
  317.     /* get the next conditional */
  318.     list = car(args);
  319.  
  320.     /* evaluate the predicate part */
  321.     if (consp(list) && (val = xleval(car(list)))) {
  322.  
  323.         /* evaluate each expression */
  324.         for (list = cdr(list); consp(list); list = cdr(list))
  325.         val = xleval(car(list));
  326.  
  327.         /* exit the loop */
  328.         break;
  329.     }
  330.     }
  331.  
  332.     /* return the value */
  333.     return (val);
  334. }
  335.  
  336. /* xcase - special form 'case' */
  337. NODE *xcase(args)
  338.   NODE *args;
  339. {
  340.     NODE ***oldstk,*key,*list,*cases,*val;
  341.  
  342.     /* create a new stack frame */
  343.     oldstk = xlstack;
  344.     xlsave1(key);
  345.  
  346.     /* get the key expression */
  347.     key = xlevarg(&args);
  348.  
  349.     /* find a case that matches */
  350.     for (val = NIL; consp(args); args = cdr(args)) {
  351.  
  352.     /* get the next case clause */
  353.     list = car(args);
  354.  
  355.     /* make sure this is a valid clause */
  356.     if (consp(list)) {
  357.  
  358.         /* compare the key list against the key */
  359.         if ((cases = car(list)) == true ||
  360.                 (listp(cases) && keypresent(key,cases)) ||
  361.                 eql(key,cases)) {
  362.  
  363.         /* evaluate each expression */
  364.         for (list = cdr(list); consp(list); list = cdr(list))
  365.             val = xleval(car(list));
  366.  
  367.         /* exit the loop */
  368.         break;
  369.         }
  370.     }
  371.     else
  372.         xlerror("bad case clause",list);
  373.     }
  374.  
  375.     /* restore the previous stack frame */
  376.     xlstack = oldstk;
  377.  
  378.     /* return the value */
  379.     return (val);
  380. }
  381.  
  382. /* keypresent - check for the presence of a key in a list */
  383. LOCAL int keypresent(key,list)
  384.   NODE *key,*list;
  385. {
  386.     for (; consp(list); list = cdr(list))
  387.     if (eql(car(list),key))
  388.         return (TRUE);
  389.     return (FALSE);
  390. }
  391.  
  392. /* xand - special form 'and' */
  393. NODE *xand(args)
  394.   NODE *args;
  395. {
  396.     NODE *val;
  397.  
  398.     /* evaluate each argument */
  399.     for (val = true; consp(args); args = cdr(args))
  400.     if ((val = xleval(car(args))) == NIL)
  401.         break;
  402.  
  403.     /* return the result value */
  404.     return (val);
  405. }
  406.  
  407. /* xor - special form 'or' */
  408. NODE *xor(args)
  409.   NODE *args;
  410. {
  411.     NODE *val;
  412.  
  413.     /* evaluate each argument */
  414.     for (val = NIL; consp(args); args = cdr(args))
  415.     if ((val = xleval(car(args))))
  416.         break;
  417.  
  418.     /* return the result value */
  419.     return (val);
  420. }
  421.  
  422. /* xif - special form 'if' */
  423. NODE *xif(args)
  424.   NODE *args;
  425. {
  426.     NODE *testexpr,*thenexpr,*elseexpr;
  427.  
  428.     /* get the test expression, then clause and else clause */
  429.     testexpr = xlarg(&args);
  430.     thenexpr = xlarg(&args);
  431.     elseexpr = (args ? xlarg(&args) : NIL);
  432.     xllastarg(args);
  433.  
  434.     /* evaluate the appropriate clause */
  435.     return (xleval(xleval(testexpr) ? thenexpr : elseexpr));
  436. }
  437.  
  438. /* xlet - special form 'let' */
  439. NODE *xlet(args)
  440.   NODE *args;
  441. {
  442.     return (let(args,TRUE));
  443. }
  444.  
  445. /* xletstar - special form 'let*' */
  446. NODE *xletstar(args)
  447.   NODE *args;
  448. {
  449.     return (let(args,FALSE));
  450. }
  451.  
  452. /* let - common let routine */
  453. LOCAL NODE *let(args,pflag)
  454.   NODE *args; int pflag;
  455. {
  456.     NODE ***oldstk,*newenv,*val;
  457.  
  458.     /* create a new stack frame */
  459.     oldstk = xlstack;
  460.     xlsave1(newenv);
  461.  
  462.     /* create a new environment frame */
  463.     newenv = xlframe(xlenv);
  464.  
  465.     /* get the list of bindings and bind the symbols */
  466.     if (!pflag) xlenv = newenv;
  467.     dobindings(xlmatch(LIST,&args),newenv);
  468.     if (pflag) xlenv = newenv;
  469.  
  470.     /* execute the code */
  471.     for (val = NIL; consp(args); args = cdr(args))
  472.     val = xleval(car(args));
  473.  
  474.     /* unbind the arguments */
  475.     xlenv = cdr(xlenv);
  476.  
  477.     /* restore the previous stack frame */
  478.     xlstack = oldstk;
  479.  
  480.     /* return the result */
  481.     return (val);
  482. }
  483.  
  484. /* xprog - special form 'prog' */
  485. NODE *xprog(args)
  486.   NODE *args;
  487. {
  488.     return (prog(args,TRUE));
  489. }
  490.  
  491. /* xprogstar - special form 'prog*' */
  492. NODE *xprogstar(args)
  493.   NODE *args;
  494. {
  495.     return (prog(args,FALSE));
  496. }
  497.  
  498. /* prog - common prog routine */
  499. LOCAL NODE *prog(args,pflag)
  500.   NODE *args; int pflag;
  501. {
  502.     NODE ***oldstk,*newenv,*val;
  503.  
  504.     /* create a new stack frame */
  505.     oldstk = xlstack;
  506.     xlsave1(newenv);
  507.  
  508.     /* create a new environment frame */
  509.     newenv = xlframe(xlenv);
  510.  
  511.     /* get the list of bindings and bind the symbols */
  512.     if (!pflag) xlenv = newenv;
  513.     dobindings(xlmatch(LIST,&args),newenv);
  514.     if (pflag) xlenv = newenv;
  515.  
  516.     /* execute the code */
  517.     tagblock(args,&val);
  518.  
  519.     /* unbind the arguments */
  520.     xlenv = cdr(xlenv);
  521.  
  522.     /* restore the previous stack frame */
  523.     xlstack = oldstk;
  524.  
  525.     /* return the result */
  526.     return (val);
  527. }
  528.  
  529. /* xgo - special form 'go' */
  530. NODE *xgo(args)
  531.   NODE *args;
  532. {
  533.     NODE *label;
  534.  
  535.     /* get the target label */
  536.     label = xlarg(&args);
  537.     xllastarg(args);
  538.  
  539.     /* transfer to the label */
  540.     xlgo(label);
  541. }
  542.  
  543. /* xreturn - special form 'return' */
  544. NODE *xreturn(args)
  545.   NODE *args;
  546. {
  547.     NODE *val;
  548.  
  549.     /* get the return value */
  550.     val = (args ? xlevarg(&args) : NIL);
  551.     xllastarg(args);
  552.  
  553.     /* return from the inner most block */
  554.     xlreturn(val);
  555. }
  556.  
  557. /* xprog1 - special form 'prog1' */
  558. NODE *xprog1(args)
  559.   NODE *args;
  560. {
  561.     return (progx(args,1));
  562. }
  563.  
  564. /* xprog2 - special form 'prog2' */
  565. NODE *xprog2(args)
  566.   NODE *args;
  567. {
  568.     return (progx(args,2));
  569. }
  570.  
  571. /* progx - common progx code */
  572. LOCAL NODE *progx(args,n)
  573.   NODE *args; int n;
  574. {
  575.     NODE ***oldstk,*val;
  576.  
  577.     /* create a new stack frame */
  578.     oldstk = xlstack;
  579.     xlsave1(val);
  580.  
  581.     /* evaluate the first n expressions */
  582.     for (; consp(args) && --n >= 0; args = cdr(args))
  583.     val = xleval(car(args));
  584.  
  585.     /* evaluate each remaining argument */
  586.     for (; consp(args); args = cdr(args))
  587.     xleval(car(args));
  588.  
  589.     /* restore the previous stack frame */
  590.     xlstack = oldstk;
  591.  
  592.     /* return the last test expression value */
  593.     return (val);
  594. }
  595.  
  596. /* xprogn - special form 'progn' */
  597. NODE *xprogn(args)
  598.   NODE *args;
  599. {
  600.     NODE *val;
  601.  
  602.     /* evaluate each expression */
  603.     for (val = NIL; consp(args); args = cdr(args))
  604.     val = xleval(car(args));
  605.  
  606.     /* return the last test expression value */
  607.     return (val);
  608. }
  609.  
  610. /* xdo - special form 'do' */
  611. NODE *xdo(args)
  612.   NODE *args;
  613. {
  614.     return (doloop(args,TRUE));
  615. }
  616.  
  617. /* xdostar - special form 'do*' */
  618. NODE *xdostar(args)
  619.   NODE *args;
  620. {
  621.     return (doloop(args,FALSE));
  622. }
  623.  
  624. /* doloop - common do routine */
  625. LOCAL NODE *doloop(args,pflag)
  626.   NODE *args; int pflag;
  627. {
  628.     NODE ***oldstk,*newenv,*blist,*clist,*test,*rval;
  629.     int rbreak;
  630.  
  631.     /* create a new stack frame */
  632.     oldstk = xlstack;
  633.     xlsave1(newenv);
  634.  
  635.     /* get the list of bindings, the exit test and the result forms */
  636.     blist = xlmatch(LIST,&args);
  637.     clist = xlmatch(LIST,&args);
  638.     test = (consp(clist) ? car(clist) : NIL);
  639.  
  640.     /* create a new environment frame */
  641.     newenv = xlframe(xlenv);
  642.  
  643.     /* bind the symbols */
  644.     if (!pflag) xlenv = newenv;
  645.     dobindings(blist,newenv);
  646.     if (pflag) xlenv = newenv;
  647.  
  648.     /* execute the loop as long as the test is false */
  649.     for (rbreak = FALSE; xleval(test) == NIL; doupdates(blist,pflag))
  650.     if (tagblock(args,&rval)) {
  651.         rbreak = TRUE;
  652.         break;
  653.     }
  654.  
  655.     /* evaluate the result expression */
  656.     if (!rbreak && consp(clist))
  657.     for (rval = NIL, clist = cdr(clist); consp(clist); clist = cdr(clist))
  658.         rval = xleval(car(clist));
  659.  
  660.     /* unbind the arguments */
  661.     xlenv = cdr(xlenv);
  662.  
  663.     /* restore the previous stack frame */
  664.     xlstack = oldstk;
  665.  
  666.     /* return the result */
  667.     return (rval);
  668. }
  669.  
  670. /* xdolist - special form 'dolist' */
  671. NODE *xdolist(args)
  672.   NODE *args;
  673. {
  674.     NODE ***oldstk,*clist,*sym,*list,*rval;
  675.     int rbreak;
  676.  
  677.     /* create a new stack frame */
  678.     oldstk = xlstack;
  679.     xlsave1(list);
  680.  
  681.     /* get the control list (sym list result-expr) */
  682.     clist = xlmatch(LIST,&args);
  683.     sym = xlmatch(SYM,&clist);
  684.     list = xlevmatch(LIST,&clist);
  685.  
  686.     /* initialize the local environment */
  687.     xlenv = xlframe(xlenv);
  688.     xlbind(sym,NIL,xlenv);
  689.  
  690.     /* loop through the list */
  691.     for (rbreak = FALSE; consp(list); list = cdr(list)) {
  692.  
  693.     /* bind the symbol to the next list element */
  694.     xlsetvalue(sym,car(list));
  695.  
  696.     /* execute the loop body */
  697.     if (tagblock(args,&rval)) {
  698.         rbreak = TRUE;
  699.         break;
  700.     }
  701.     }
  702.  
  703.     /* evaluate the result expression */
  704.     if (!rbreak) {
  705.     xlsetvalue(sym,NIL);
  706.     rval = (consp(clist) ? xleval(car(clist)) : NIL);
  707.     }
  708.  
  709.     /* unbind the arguments */
  710.     xlenv = cdr(xlenv);
  711.  
  712.     /* restore the previous stack frame */
  713.     xlstack = oldstk;
  714.  
  715.     /* return the result */
  716.     return (rval);
  717. }
  718.  
  719. /* xdotimes - special form 'dotimes' */
  720. NODE *xdotimes(args)
  721.   NODE *args;
  722. {
  723.     NODE *clist,*sym,*rval;
  724.     int rbreak,cnt,i;
  725.  
  726.     /* get the control list (sym list result-expr) */
  727.     clist = xlmatch(LIST,&args);
  728.     sym = xlmatch(SYM,&clist);
  729.     cnt = getfixnum(xlevmatch(INT,&clist));
  730.  
  731.     /* initialize the local environment */
  732.     xlenv = xlframe(xlenv);
  733.     xlbind(sym,NIL,xlenv);
  734.  
  735.     /* loop through for each value from zero to cnt-1 */
  736.     for (rbreak = FALSE, i = 0; i < cnt; ++i) {
  737.  
  738.     /* bind the symbol to the next list element */
  739.     xlsetvalue(sym,cvfixnum((FIXNUM)i));
  740.  
  741.     /* execute the loop body */
  742.     if (tagblock(args,&rval)) {
  743.         rbreak = TRUE;
  744.         break;
  745.     }
  746.     }
  747.  
  748.     /* evaluate the result expression */
  749.     if (!rbreak) {
  750.     xlsetvalue(sym,cvfixnum((FIXNUM)cnt));
  751.     rval = (consp(clist) ? xleval(car(clist)) : NIL);
  752.     }
  753.  
  754.     /* unbind the arguments */
  755.     xlenv = cdr(xlenv);
  756.  
  757.     /* return the result */
  758.     return (rval);
  759. }
  760.  
  761. /* xcatch - special form 'catch' */
  762. NODE *xcatch(args)
  763.   NODE *args;
  764. {
  765.     NODE ***oldstk,*tag,*val;
  766.     CONTEXT cntxt;
  767.  
  768.     /* create a new stack frame */
  769.     oldstk = xlstack;
  770.     xlsave1(tag);
  771.  
  772.     /* get the tag */
  773.     tag = xlevarg(&args);
  774.  
  775.     /* establish an execution context */
  776.     xlbegin(&cntxt,CF_THROW,tag);
  777.  
  778.     /* check for 'throw' */
  779.     if (setjmp(cntxt.c_jmpbuf))
  780.     val = xlvalue;
  781.  
  782.     /* otherwise, evaluate the remainder of the arguments */
  783.     else {
  784.     for (val = NIL; consp(args); args = cdr(args))
  785.         val = xleval(car(args));
  786.     }
  787.     xlend(&cntxt);
  788.  
  789.     /* restore the previous stack frame */
  790.     xlstack = oldstk;
  791.  
  792.     /* return the result */
  793.     return (val);
  794. }
  795.  
  796. /* xthrow - special form 'throw' */
  797. NODE *xthrow(args)
  798.   NODE *args;
  799. {
  800.     NODE *tag,*val;
  801.  
  802.     /* get the tag and value */
  803.     tag = xlevarg(&args);
  804.     val = (args ? xlevarg(&args) : NIL);
  805.     xllastarg(args);
  806.  
  807.     /* throw the tag */
  808.     xlthrow(tag,val);
  809. }
  810.  
  811. /* xerrset - special form 'errset' */
  812. NODE *xerrset(args)
  813.   NODE *args;
  814. {
  815.     NODE *expr,*flag,*val;
  816.     CONTEXT cntxt;
  817.  
  818.     /* get the expression and the print flag */
  819.     expr = xlarg(&args);
  820.     flag = (args ? xlarg(&args) : true);
  821.     xllastarg(args);
  822.  
  823.     /* establish an execution context */
  824.     xlbegin(&cntxt,CF_ERROR,flag);
  825.  
  826.     /* check for error */
  827.     if (setjmp(cntxt.c_jmpbuf))
  828.     val = NIL;
  829.  
  830.     /* otherwise, evaluate the expression */
  831.     else {
  832.     expr = xleval(expr);
  833.     val = consa(expr);
  834.     }
  835.     xlend(&cntxt);
  836.  
  837.     /* return the result */
  838.     return (val);
  839. }
  840.  
  841. /* dobindings - handle bindings for let/let*, prog/prog*, do/do* */
  842. LOCAL dobindings(list,env)
  843.   NODE *list,*env;
  844. {
  845.     NODE ***oldstk,*bnd,*sym,*val;
  846.  
  847.     /* create a new stack frame */
  848.     oldstk = xlstack;
  849.     xlsave1(val);
  850.  
  851.     /* bind each symbol in the list of bindings */
  852.     for (; consp(list); list = cdr(list)) {
  853.  
  854.     /* get the next binding */
  855.     bnd = car(list);
  856.  
  857.     /* handle a symbol */
  858.     if (symbolp(bnd)) {
  859.         sym = bnd;
  860.         val = NIL;
  861.     }
  862.  
  863.     /* handle a list of the form (symbol expr) */
  864.     else if (consp(bnd)) {
  865.         sym = xlmatch(SYM,&bnd);
  866.         val = xlevarg(&bnd);
  867.     }
  868.     else
  869.         xlfail("bad binding");
  870.  
  871.     /* bind the value to the symbol */
  872.     xlbind(sym,val,env);
  873.     }
  874.  
  875.     /* restore the previous stack frame */
  876.     xlstack = oldstk;
  877. }
  878.  
  879. /* doupdates - handle updates for do/do* */
  880. doupdates(list,pflag)
  881.   NODE *list; int pflag;
  882. {
  883.     NODE ***oldstk,*plist,*bnd,*sym,*val;
  884.  
  885.     /* create a new stack frame */
  886.     oldstk = xlstack;
  887.     xlstkcheck(2);
  888.     xlsave(plist);
  889.     xlsave(val);
  890.  
  891.     /* bind each symbol in the list of bindings */
  892.     for (; consp(list); list = cdr(list)) {
  893.  
  894.     /* get the next binding */
  895.     bnd = car(list);
  896.  
  897.     /* handle a list of the form (symbol expr) */
  898.     if (consp(bnd)) {
  899.         sym = xlmatch(SYM,&bnd);
  900.         bnd = cdr(bnd);
  901.         if (bnd) {
  902.         val = xlevarg(&bnd);
  903.         if (pflag)
  904.             plist = cons(cons(sym,val),plist);
  905.         else
  906.             xlsetvalue(sym,val);
  907.         }
  908.     }
  909.     }
  910.  
  911.     /* set the values for parallel updates */
  912.     for (; plist; plist = cdr(plist))
  913.     xlsetvalue(car(car(plist)),cdr(car(plist)));
  914.  
  915.     /* restore the previous stack frame */
  916.     xlstack = oldstk;
  917. }
  918.  
  919. /* tagblock - execute code within a block and tagbody */
  920. int tagblock(code,pval)
  921.   NODE *code,**pval;
  922. {
  923.     CONTEXT cntxt;
  924.     int type,sts;
  925.  
  926.     /* establish an execution context */
  927.     xlbegin(&cntxt,CF_GO|CF_RETURN,code);
  928.  
  929.     /* check for a 'return' */
  930.     if ((type = setjmp(cntxt.c_jmpbuf)) == CF_RETURN) {
  931.     *pval = xlvalue;
  932.     sts = TRUE;
  933.     }
  934.  
  935.     /* otherwise, enter the body */
  936.     else {
  937.  
  938.     /* check for a 'go' */
  939.     if (type == CF_GO)
  940.         code = xlvalue;
  941.  
  942.     /* evaluate each expression in the body */
  943.     for (; consp(code); code = cdr(code))
  944.         if (consp(car(code)))
  945.         xleval(car(code));
  946.  
  947.     /* fell out the bottom of the loop */
  948.     *pval = NIL;
  949.     sts = FALSE;
  950.     }
  951.     xlend(&cntxt);
  952.  
  953.     /* return status */
  954.     return (sts);
  955. }
  956.  
  957.